Simtel MSDOS 1995 January/Simtel - 10000 MSDOS Shareware Programs (Walnut Creek)(January 1995)(Disc 1).ISO/starter/uudecode.tp5

Pascal/Delphi Source File | 1990-05-08 | 5KB | 230 lines

PROGRAM uudecode;

{v1.1 Toad Hall Tweak, 9 May 90
 - Reformatted in case, style, indentation, etc. to my preferences.
 - Tweaked for Turbo Pascal v5.0
 David Kirschbaum
 Toad Hall
}

Uses  Dos,Crt;

CONST
  DefaultSuffix = '.uue';
  OFFSET = 32;

TYPE
  Str80 = STRING[80];

VAR
  Infile: TEXT;
  Fi    : FILE OF Byte;
  Outfile: FILE OF Byte;
  linenum: INTEGER;
  Line: Str80;
  size,remaining : longint;  {v1.1 REAL;}


PROCEDURE Abort(Msg: Str80);
  BEGIN
    WRITELN;
    IF linenum > 0 THEN WRITE('Line ', linenum, ': ');
    WRITELN(Msg);
    HALT
  END; {of Abort}


PROCEDURE NextLine(VAR S: Str80);
  BEGIN
    Inc(linenum);
    {write('.');}
    READLN(Infile, S);
    Dec(remaining,LENGTH(S)-2);  {-2 is for CR/LF}
    WRITE('bytes remaining: ',remaining:7,' (',
          remaining/size*100.0:3:0,'%)',CHR(13));
  END; {of NextLine}


PROCEDURE Init;

  PROCEDURE GetInFile;
    VAR Infilename: Str80;
    BEGIN
      IF ParamCount = 0 THEN Abort ('Usage: uudecode <filename>');

      Infilename := ParamStr(1);
      IF POS('.', Infilename) = 0
      THEN Infilename := CONCAT(Infilename, DefaultSuffix);
      ASSIGN(Infile, Infilename);
      {$I-}
      RESET(Infile);
      {$i+}
      IF IOResult > 0 THEN Abort (CONCAT('Can''t open ', Infilename));

      WRITELN ('Decoding ', Infilename);
      ASSIGN(Fi,Infilename); RESET(Fi);
      size := FileSize(Fi);
      CLOSE(Fi);
{      IF size < 0 THEN size:=size+65536.0; }
      remaining := size;
    END;  {of GetInFile}

  PROCEDURE GetOutFile;
    VAR
      Header, Mode, Outfilename: Str80;
      Ch: CHAR;

    PROCEDURE ParseHeader;
      VAR index: INTEGER;

      PROCEDURE NextWord(VAR Word:Str80; VAR index: INTEGER);
        BEGIN
          Word := '';
          WHILE Header[index] = ' ' DO BEGIN
            Inc(index);
            IF index > LENGTH(Header) THEN Abort ('Incomplete header')
          END;
          WHILE Header[index] <> ' ' DO BEGIN
            Word := CONCAT(Word, Header[index]);
            Inc(index);
          END
        END; {of NextWord}

      BEGIN {ParseHeader}
        Header := CONCAT(Header, ' ');
        index := 7;
        NextWord(Mode, index);
        NextWord(Outfilename, index)
      END; {of ParseHeader}

    BEGIN {GetOutFile}
      IF EOF(Infile) THEN Abort('Nothing to decode.');
      NextLine (Header);
      WHILE NOT ((COPY(Header, 1, 6) = 'begin ') OR EOF(Infile)) DO
        NextLine(Header);
      WRITELN;
      IF EOF(Infile) THEN Abort('Nothing to decode.');

      ParseHeader;
      ASSIGN(Outfile, Outfilename);
      WRITELN ('Destination is ', Outfilename);
      {$I-}
      RESET(Outfile);
      {$I+}
      IF IOResult = 0 THEN BEGIN
        WRITE ('Overwrite current ', Outfilename, '? [Y/N] ');
        REPEAT
          Ch := Upcase(ReadKey);  {v1.1}
        UNTIL Ch IN ['Y', 'N'];
        WRITELN(Ch);
        IF Ch = 'N' THEN Abort ('Overwrite cancelled.')
      END;
      REWRITE (Outfile);
    END; {of GetOutFile}

  BEGIN {Init}
    linenum := 0;
    GetInFile;
    GetOutFile;
  END; { init}

FUNCTION Check_Line: BOOLEAN;
  BEGIN
    IF Line = '' THEN Abort ('Blank line in file');
    Check_Line := NOT (Line[1] IN [' ', '`'])
  END; {of Check_Line}


PROCEDURE DecodeLine;
  VAR
    lineIndex, byteNum, count, i: INTEGER;
    chars: ARRAY [0..3] OF Byte;
    hunk: ARRAY [0..2] OF Byte;

{    procedure debug;
      var i: integer;

      procedure writebin(x: byte);
        var i: integer;
        begin
          for i := 1 to 8 do begin
              write ((x and $80) shr 7);
              x := x shl 1
            end;
          write (' ')
        end;

      begin
        writeln;
        for i := 0 to 3 do writebin(chars[i]);
        writeln;
        for i := 0 to 2 do writebin(hunk[i]);
        writeln
      end;      }


  FUNCTION Next_Ch: CHAR;
    BEGIN
      Inc(lineIndex);
      IF lineIndex > LENGTH(Line) THEN Abort('Line too short.');

      IF NOT (Line[lineindex] IN [' '..'`'])
      THEN Abort('Illegal character in line.');
{     write(line[lineindex]:2);}
      IF Line[lineindex] = '`' THEN Next_Ch := ' '
                               ELSE Next_Ch := Line[lineIndex]
    END; {of Next_Ch}


  PROCEDURE DecodeByte;

    PROCEDURE GetNextHunk;
      VAR i: INTEGER;
      BEGIN
        FOR i := 0 TO 3 DO chars[i] := ORD(Next_Ch) - OFFSET;
        hunk[0] := (chars[0] ShL 2) + (chars[1] ShR 4);
        hunk[1] := (chars[1] ShL 4) + (chars[2] ShR 2);
        hunk[2] := (chars[2] ShL 6) + chars[3];
        byteNum := 0  {;
        debug          }
      END; {of GetNextHunk}

    BEGIN {DecodeByte}
      IF byteNum = 3 THEN GetNextHunk;
      WRITE (Outfile, hunk[byteNum]);
      {writeln(bytenum, ' ', hunk[byteNum]);}
      Inc(byteNum)
    END; {of DecodeByte}

  BEGIN {DecodeLine}
    lineIndex := 0;
    byteNum := 3;
    count := (ORD(Next_Ch) - OFFSET);
    FOR i := 1 TO count DO DecodeByte
  END; {of DecodeLine}


PROCEDURE Terminate;
  VAR Trailer: Str80;
  BEGIN
    IF EOF(Infile) THEN Abort ('Abnormal end.');

    NextLine (trailer);
    IF LENGTH (trailer) < 3 THEN Abort ('Abnormal end.');

    IF COPY (trailer, 1, 3) <> 'end' THEN Abort ('Abnormal end.');

    CLOSE (Infile);
    CLOSE (Outfile)
  END;  {of Terminate}

BEGIN {uudecode}
  Init;
  NextLine(Line);
  WHILE Check_Line DO BEGIN
    DecodeLine;
    NextLine(Line)
  END;
  Terminate
END.